home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
9.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
18KB
|
637 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#include "hdr.h"
#include "vars.h"
#include "setp.h"
#include "errmsgp.h"
#include "miscp.h"
#include "smiscp.h"
#include "nodesp.h"
#include "dclmapp.h"
#include "chapp.h"
void task_spec(Node task_node) /*;task_spec*/
{
Node entries_node, id_node;
int anon;
Symbol task_type_name, t_name, old_kind, entry_sym;
char *id;
Declaredmap entry_list;
Fordeclared fd1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : task_spec");
id_node = N_AST1(task_node);
entries_node = N_AST2(task_node);
#ifdef TBSN
/* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
* DS 9-22-86
*/
opt_specs_node = N_AST3(task_node);
#endif
/*
* If this is a task declaration, an anonymous task type is introduced
* for it. Entry declarations are always attached to the task type.
* TBSL : processing of specifications.
*/
anon = (N_KIND(task_node) == as_task_spec);
id = N_VAL(id_node);
if (anon)
task_type_name =
find_new(strjoin(strjoin("task_type:", id), newat_str()));
else
task_type_name = find_type_name(id_node);
if (task_type_name == symbol_any) return; /* Illegal redeclaration. */
if (anon) {
#ifdef TBSN
XREF lessf:= task_type_name;
#endif
}
old_kind = TYPE_OF(task_type_name); /* may have been private */
NATURE(task_type_name) = na_task_type_spec;
TYPE_OF(task_type_name) = task_type_name;
SIGNATURE(task_type_name) = tup_new(0); /* created by the expander */
root_type(task_type_name) = task_type_name;
initialize_representation_info(task_type_name, TAG_TASK);
/* priv_types is {private, limited_private}; first arg to check_priv_decl
* is one of MISC_TYPE_ATTRIBUTES ...
*/
if (old_kind == symbol_private)
check_priv_decl(TA_PRIVATE, task_type_name);
else if (old_kind == symbol_limited_private)
check_priv_decl(TA_LIMITED_PRIVATE, task_type_name);
if (anon) {
t_name = find_new(id);
NATURE(t_name) = na_task_obj_spec;
TYPE_OF(t_name) = task_type_name;
SIGNATURE(t_name) = (Tuple) 0;
N_UNQ(task_node) = t_name;
}
N_TYPE(task_node) = task_type_name;
newscope(task_type_name); /* introduce new scope */
#ifdef TBSN
prefix := prefix + id + '.'; $ For unique names.
#endif
sem_list(entries_node);
#ifdef TBSN
/* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
* DS 9-22-86
*/
sem_list(opt_specs_node);
#endif
entry_list = DECLARED(scope_name);
popscope();
if (anon) {
/* Attach entry declarations for task object as well, and emit a
* declaration for the task object itself.
*/
SIGNATURE(t_name) = (Tuple) 0;
DECLARED(t_name) = entry_list;
FORDECLARED(id, entry_sym, entry_list, fd1)
/*(for entry = entry_list(id))*/
SCOPE_OF(entry_sym) = t_name;
ENDFORDECLARED(fd1)
}
return;
}
void accept_statement(Node accept_node) /*;accept_statement*/
{
/* This procedure opens a new scope when an ACCEPT statement is seen.
* In the case of an overloaded entry name, it selects the one with
* the matching signature.
*/
int certain;
Symbol task_name, task_type, real_name, entry_name, ix_t;
Set entries;
Tuple formals;
Forset fs1;
Node id_node, indx, body_node;
Node formals_node;
int exists, nat;
char *id, *junk;
Fortup ft1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : accept_statement");
id_node = N_AST1(accept_node);
indx = N_AST2(accept_node);
formals_node = N_AST3(accept_node);
body_node = N_AST4(accept_node);
id = N_VAL(id_node);
formals = get_formals(formals_node, id);
/* Find the task in which the accept statement occurs. The accept
* may of course appear within a block or another accept statement.
*/
exists = FALSE;
FORTUP(task_name = (Symbol), open_scopes, ft1);
nat = NATURE(task_name);
if( nat != na_block && nat != na_entry && nat != na_entry_family) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
certain = exists;
task_type = TYPE_OF(task_name);
if (task_type == (Symbol)0 || NATURE(task_type) != na_task_type) {
errmsg("Accept statements can only appear in tasks","9.5", accept_node);
/* following junk line in SETL not needed here ds 1 nov 84
* entry_name = id;
*/
return;
}
real_name = entry_name = dcl_get(DECLARED(task_name), id);
if (entry_name == (Symbol)0) {
errmsg("Undefined entry name in ACCEPT ", "9.5", id_node);
#ifdef TBSL
-- entry_name is symbol, id is string ds 2-jan-85
entry_name = id; /* For dummy scope. */
#endif
return; /* to Initialize it . */
}
else if (NATURE(entry_name) == na_entry) {
/* Collect all its overloadings and select the one with the
* correct signature.
*/
entries = OVERLOADS(entry_name);
if (indx != OPT_NODE) {
errmsg("invalid index on entry (not entry family)", "9.5", indx);
}
exists = FALSE;
FORSET(entry_name = (Symbol), entries, fs1);
if (same_sig_spec(entry_name, formals)) {
exists = TRUE;
break;
}
ENDFORSET(fs1);
if (!exists) {
errmsg("Entry name in ACCEPT statement does not match any entry" ,
"9.5", id_node);
return;
}
}
else if (NATURE(entry_name) == na_entry_family) {
ix_t = (Symbol) index_type(TYPE_OF(entry_name));
if (indx == OPT_NODE) {
errmsg("Missing index for entry family.", "9.5", accept_node);
}
else {
adasem(indx);
check_type(ix_t, indx);
}
}
else {
errmsg("Invalid entry name in ACCEPT", "9.5", id_node);
return;
}
N_UNQ(id_node) = entry_name;
TO_XREF(entry_name);
reprocess_formals(entry_name, formals_node);
if (in_open_scopes(entry_name )) {
errmsg_l("An accept_statement cannot appear within an ACCEPT for",
" the same entry", "9.5", accept_node);
}
newscope(entry_name);
has_return_stk = tup_with(has_return_stk, (char *)FALSE);
adasem(body_node);
junk = tup_frome(has_return_stk);
popscope();
}
void entry_decl(Node entry_node) /*;entry_decl*/
{
/* An entry declaration is treated like a procedure specification.
* An anonymous type is created for the entry object. This type is
* used by the interpreter to build the environment of an entry.
*/
Symbol entry_sym, entry_type;
Node id_node, formal_list;
Tuple formals;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_decl");
id_node = N_AST1(entry_node);
formal_list = N_AST2(entry_node);
formals = get_formals(formal_list, N_VAL(id_node));
check_out_parameters(formals);
/*entry = chain_overloads(N_VAL(id_node), [na_entry, 'none', formals]); */
entry_sym = chain_overloads(N_VAL(id_node), na_entry, symbol_none,
formals, (Symbol)0, formal_list);
entry_type = anonymous_type();
/*SYMBTAB(entry_type) := [na_entry_former, scope_name, signature(entry)]; */
NATURE(entry_type) = na_entry_former;
TYPE_OF(entry_type) = scope_name;
SIGNATURE(entry_type) = SIGNATURE(entry_sym);
root_type(entry_type) = entry_type;
N_UNQ(id_node) = entry_sym;
N_TYPE(entry_node) = entry_type;
}
void entry_family_decl(Node entry_node) /*;entry_family_decl*/
{
/* An entry family is not an overloadable object. It is constructed
* as an array of entries. An anonymous type is introduced for the entry
* former, just as for an entry declaration, and another is introduced
* for the array representing the family.
*/
Symbol entry_sym, entry_type, family_type;
Symbol opt_range;
Tuple formals, f, tup;
Node id_node, discrete_range, formal_list;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_family_decl");
id_node = N_AST1(entry_node);
discrete_range = N_AST2(entry_node);
formal_list = N_AST3(entry_node);
entry_sym = find_new(N_VAL(id_node));
formals = get_formals(formal_list, N_VAL(id_node));
check_out_parameters(formals);
f = process_formals(entry_sym, formals, TRUE);
entry_type = anonymous_type();
NATURE(entry_type) = na_entry_former;
TYPE_OF(entry_type) = scope_name;
SIGNATURE(entry_type) = f;
root_type(entry_type) = entry_type;
adasem(discrete_range);
opt_range = make_index(discrete_range);
family_type = anonymous_type();
/* SYMBTAB(family_type) =
* [na_array, family_type, [[opt_range], entry_type]];
*/
NATUR